Through mapping both covid tests and positives adjusted for population, we hope to fine if any relation between the two exists. It may be possible that more tests mean more covid.
Load packages
The following packages are used:
knitr– load datasets
tidverse– mutate data
janitor– clean names
lubridate – work with dates
here– give file locations
library(knitr)
library(tidyverse)
library(janitor)
library(lubridate)
library(here)
Additional packages being used
tmap– for mapping purposes
sf– joining spacial data and generating plots
tidycensus– loading census data
library(tmap)
library(sf)
library(tidycensus)
Load testing data
The test data is loaded into R, and mutated to become non-cumulative
df1=readxl::read_excel(here("submissions","bike_share","data","tot_tests_neighborhood.xlsx")) %>%
clean_names() %>%
#mutate(date_reported= as_datetime(date_reported))
separate(date_reported,into=c("date","hr"),sep = " ")%>%
mutate(date_report=as_date(date))%>%
group_by(neighborhood)%>%
mutate(across(total_tests, ~ .-c(0,lag(.)[-1])))
Load Mapping Data
Loads in the Health neighbourhood geojson file.
neigh=st_read(here("submissions","bike_share","data","dc_neigh.geojson")) %>% clean_names()
Reading layer `DC_Health_Planning_Neighborhoods' from data source
`D:\KALTENBACH_ENGINEERING\Master\CU\R_Workspace\Portfolio_DS\submissions\bike_share\data\dc_neigh.geojson'
using driver `GeoJSON'
Simple feature collection with 51 features and 8 fields
Geometry type: POLYGON
Dimension: XY
Bounding box: xmin: -77.11976 ymin: 38.79165 xmax: -76.9094 ymax: 38.99556
Geodetic CRS: WGS 84
class(neigh)
[1] "sf" "data.frame"
Select and clean data
Cleans testing data so it can be joined with the health neighborhood spacial data
df_tests=df1 %>%
filter(as_date(date_report) == "2021/10/27") %>%
separate(neighborhood,into=c("code","name"),sep = ":") %>%
mutate(code=case_when(
code=="N35" ~"N0",
TRUE ~ code
))
Join mapping data with test data
Joins data and generates plot
neigh2=left_join(neigh,df_tests,by=c("code"))
tmap_mode("view")
tmap mode set to interactive viewing
tm_shape(neigh2) +tm_polygons("total_tests",alpha=.5)
Load positive cases data
Reads in positive coivd cases data and cleans it so it can be joined to the above datasets
df_c=readxl::read_excel(here("submissions","bike_share","data","neigh_cases.xlsx"),
col_types = c("date", "text", "numeric")) %>%
clean_names()
df_cases=df_c %>%
filter(as_date(date) == "2021/10/27") %>%
separate(neighborhood,into=c("code","name"),sep = ":") %>%
mutate(code=case_when(
code=="N35" ~"N0",
TRUE ~ code
))
Join covid data
neigh3=left_join(neigh2,df_cases,by=c("code"))
tmap_mode("view")
tmap mode set to interactive viewing
tm_shape(neigh3) +tm_polygons("total_positives",alpha=.5)
Graph data
tm_shape(neigh3)+tm_polygons(c("total_positives","total_tests"),alpha=.5)
Get census Data
Census data is used to normalize both tests and COVID data for population
census_api_key("2c8b9d5c4902b7efb4e1f98b2c23692cb1b73e95")
To install your API key for use in future sessions, run this function with `install = TRUE`.
v20 = load_variables(2018,"acs5")
df_cencus=get_acs(geography = "tract",
variables=c("pop"="B01001_001"),
state="DC",geometry=TRUE,year=2018)
Getting data from the 2014-2018 5-year ACS
Downloading feature geometry from the Census website. To cache shapefiles for use in future sessions, set `options(tigris_use_cache = TRUE)`.
Using FIPS code '11' for state 'DC'
df_cens=df_cencus %>% select(-moe) %>% spread(variable,estimate)
df_cens_adj=df_cens %>% st_transform(4326)
Join Census data to mapping data
df_j=st_join(df_cens_adj,neigh3,largest=TRUE)
Warning: attribute variables are assumed to be spatially constant throughout all geometries
Summarize population for each neighbourhood
df3=df_j %>% select(pop,code) %>%
group_by(code) %>%
summarise(pop_n=sum(pop))
Join population data and generate results
Removed any extreme outliers and generated map to compare testing rates and covid rates
df4=left_join(neigh3,df3 %>% st_set_geometry(NULL))
Joining, by = "code"
df4=df4 %>% mutate( covid_rate=total_positives/pop_n, test_rate=total_tests/pop_n)
df4 %>% filter(!(code %in% c("N0","N15","N24"))) %>% tm_shape()+tm_polygons(c("covid_rate","test_rate"))
LS0tDQp0aXRsZTogIkNvbXBhcmluZyBDb3ZpZCBUZXN0cyBhbmQgQ292aWQgUG9zaXRpdmVzIHVzaW5nIG1hcHBpbmcgZGF0YSINCmF1dGhvcjogIlRlYW0gNCAtIENvdmlkIERhdGEiDQpvdXRwdXQ6IGh0bWxfbm90ZWJvb2sNCi0tLQ0KDQpUaHJvdWdoIG1hcHBpbmcgYm90aCBjb3ZpZCB0ZXN0cyBhbmQgcG9zaXRpdmVzIGFkanVzdGVkIGZvciBwb3B1bGF0aW9uLCB3ZSBob3BlIHRvIGZpbmUgaWYgYW55IHJlbGF0aW9uIGJldHdlZW4gdGhlIHR3byBleGlzdHMuIEl0IG1heSBiZSBwb3NzaWJsZSB0aGF0IG1vcmUgdGVzdHMgbWVhbiBtb3JlIGNvdmlkLg0KDQojIyMgTG9hZCBwYWNrYWdlcw0KDQpUaGUgZm9sbG93aW5nIHBhY2thZ2VzIGFyZSB1c2VkOg0KDQprbml0ci0tIGxvYWQgZGF0YXNldHMNCg0KdGlkdmVyc2UtLSBtdXRhdGUgZGF0YQ0KDQpqYW5pdG9yLS0gY2xlYW4gbmFtZXMNCg0KbHVicmlkYXRlIC0tIHdvcmsgd2l0aCBkYXRlcw0KDQpoZXJlLS0gZ2l2ZSBmaWxlIGxvY2F0aW9ucw0KDQpgYGB7cn0NCmxpYnJhcnkoa25pdHIpDQpsaWJyYXJ5KHRpZHl2ZXJzZSkNCmxpYnJhcnkoamFuaXRvcikNCmxpYnJhcnkobHVicmlkYXRlKQ0KbGlicmFyeShoZXJlKQ0KYGBgDQoNCg0KIyMjIEFkZGl0aW9uYWwgcGFja2FnZXMgYmVpbmcgdXNlZA0KDQp0bWFwLS0gZm9yIG1hcHBpbmcgcHVycG9zZXMNCg0Kc2YtLSBqb2luaW5nIHNwYWNpYWwgZGF0YSBhbmQgZ2VuZXJhdGluZyBwbG90cw0KDQp0aWR5Y2Vuc3VzLS0gbG9hZGluZyBjZW5zdXMgZGF0YQ0KDQpgYGB7ciBtZXNzYWdlPUZBTFNFLCB3YXJuaW5nPUZBTFNFfQ0KbGlicmFyeSh0bWFwKQ0KbGlicmFyeShzZikNCmxpYnJhcnkodGlkeWNlbnN1cykNCmBgYA0KDQojIyMgTG9hZCB0ZXN0aW5nIGRhdGENCg0KVGhlIHRlc3QgZGF0YSBpcyBsb2FkZWQgaW50byBSLCBhbmQgbXV0YXRlZCB0byBiZWNvbWUgbm9uLWN1bXVsYXRpdmUNCg0KYGBge3IgbWVzc2FnZT1GQUxTRSwgd2FybmluZz1GQUxTRX0NCmRmMT1yZWFkeGw6OnJlYWRfZXhjZWwoaGVyZSgic3VibWlzc2lvbnMiLCJiaWtlX3NoYXJlIiwiZGF0YSIsInRvdF90ZXN0c19uZWlnaGJvcmhvb2QueGxzeCIpKSAlPiUgDQogIGNsZWFuX25hbWVzKCkgJT4lDQogICNtdXRhdGUoZGF0ZV9yZXBvcnRlZD0gYXNfZGF0ZXRpbWUoZGF0ZV9yZXBvcnRlZCkpDQogIHNlcGFyYXRlKGRhdGVfcmVwb3J0ZWQsaW50bz1jKCJkYXRlIiwiaHIiKSxzZXAgPSAiICIpJT4lDQogIG11dGF0ZShkYXRlX3JlcG9ydD1hc19kYXRlKGRhdGUpKSU+JQ0KICBncm91cF9ieShuZWlnaGJvcmhvb2QpJT4lDQogIG11dGF0ZShhY3Jvc3ModG90YWxfdGVzdHMsIH4gLi1jKDAsbGFnKC4pWy0xXSkpKQ0KYGBgDQoNCg0KIyMjIExvYWQgTWFwcGluZyBEYXRhDQoNCkxvYWRzIGluIHRoZSBIZWFsdGggbmVpZ2hib3VyaG9vZCBnZW9qc29uIGZpbGUuDQoNCmBgYHtyIG1lc3NhZ2U9RkFMU0UsIHdhcm5pbmc9RkFMU0V9DQpuZWlnaD1zdF9yZWFkKGhlcmUoInN1Ym1pc3Npb25zIiwiYmlrZV9zaGFyZSIsImRhdGEiLCJkY19uZWlnaC5nZW9qc29uIikpICU+JSBjbGVhbl9uYW1lcygpDQpjbGFzcyhuZWlnaCkNCmBgYA0KDQojIyMgU2VsZWN0IGFuZCBjbGVhbiBkYXRhDQoNCkNsZWFucyB0ZXN0aW5nIGRhdGEgc28gaXQgY2FuIGJlIGpvaW5lZCB3aXRoIHRoZSBoZWFsdGggbmVpZ2hib3Job29kIHNwYWNpYWwgZGF0YQ0KDQpgYGB7cn0NCmRmX3Rlc3RzPWRmMSAlPiUNCiAgZmlsdGVyKGFzX2RhdGUoZGF0ZV9yZXBvcnQpID09ICIyMDIxLzEwLzI3IikgJT4lIA0KICBzZXBhcmF0ZShuZWlnaGJvcmhvb2QsaW50bz1jKCJjb2RlIiwibmFtZSIpLHNlcCA9ICI6IikgJT4lIA0KICBtdXRhdGUoY29kZT1jYXNlX3doZW4oDQogICAgY29kZT09Ik4zNSIgfiJOMCIsDQogICAgVFJVRSB+IGNvZGUNCiAgKSkNCmBgYA0KDQojIyMgSm9pbiBtYXBwaW5nIGRhdGEgd2l0aCB0ZXN0IGRhdGENCg0KSm9pbnMgZGF0YSBhbmQgZ2VuZXJhdGVzIHBsb3QNCg0KYGBge3IgbWVzc2FnZT1GQUxTRSwgd2FybmluZz1GQUxTRX0NCm5laWdoMj1sZWZ0X2pvaW4obmVpZ2gsZGZfdGVzdHMsYnk9YygiY29kZSIpKSANCnRtYXBfbW9kZSgidmlldyIpDQp0bV9zaGFwZShuZWlnaDIpICt0bV9wb2x5Z29ucygidG90YWxfdGVzdHMiLGFscGhhPS41KQ0KYGBgDQoNCiMjIyBMb2FkIHBvc2l0aXZlIGNhc2VzIGRhdGENCg0KUmVhZHMgaW4gcG9zaXRpdmUgY29pdmQgY2FzZXMgZGF0YSBhbmQgY2xlYW5zIGl0IHNvIGl0IGNhbiBiZSBqb2luZWQgdG8gdGhlIGFib3ZlIGRhdGFzZXRzDQoNCmBgYHtyIG1lc3NhZ2U9RkFMU0UsIHdhcm5pbmc9RkFMU0V9DQpkZl9jPXJlYWR4bDo6cmVhZF9leGNlbChoZXJlKCJzdWJtaXNzaW9ucyIsImJpa2Vfc2hhcmUiLCJkYXRhIiwibmVpZ2hfY2FzZXMueGxzeCIpLA0KICAgICAgICAgICAgICAgICAgICAgICAgICAgIGNvbF90eXBlcyA9IGMoImRhdGUiLCAidGV4dCIsICJudW1lcmljIikpICU+JSANCiAgY2xlYW5fbmFtZXMoKSANCmRmX2Nhc2VzPWRmX2MgJT4lDQogIGZpbHRlcihhc19kYXRlKGRhdGUpID09ICIyMDIxLzEwLzI3IikgJT4lIA0KICBzZXBhcmF0ZShuZWlnaGJvcmhvb2QsaW50bz1jKCJjb2RlIiwibmFtZSIpLHNlcCA9ICI6IikgJT4lDQogIG11dGF0ZShjb2RlPWNhc2Vfd2hlbigNCiAgICBjb2RlPT0iTjM1IiB+Ik4wIiwNCiAgICBUUlVFIH4gY29kZQ0KICApKQ0KYGBgDQoNCiMjIyBKb2luIGNvdmlkIGRhdGENCg0KYGBge3J9DQpuZWlnaDM9bGVmdF9qb2luKG5laWdoMixkZl9jYXNlcyxieT1jKCJjb2RlIikpIA0KdG1hcF9tb2RlKCJ2aWV3IikNCnRtX3NoYXBlKG5laWdoMykgK3RtX3BvbHlnb25zKCJ0b3RhbF9wb3NpdGl2ZXMiLGFscGhhPS41KQ0KYGBgDQoNCiMjIyBHcmFwaCBkYXRhDQoNCmBgYHtyfQ0KIHRtX3NoYXBlKG5laWdoMykrdG1fcG9seWdvbnMoYygidG90YWxfcG9zaXRpdmVzIiwidG90YWxfdGVzdHMiKSxhbHBoYT0uNSkNCmBgYA0KDQojIyMgR2V0IGNlbnN1cyBEYXRhDQoNCkNlbnN1cyBkYXRhIGlzIHVzZWQgdG8gbm9ybWFsaXplIGJvdGggdGVzdHMgYW5kIENPVklEIGRhdGEgZm9yIHBvcHVsYXRpb24NCg0KYGBge3J9DQpjZW5zdXNfYXBpX2tleSgiMmM4YjlkNWM0OTAyYjdlZmI0ZTFmOThiMmMyMzY5MmNiMWI3M2U5NSIpDQoNCnYyMCA9IGxvYWRfdmFyaWFibGVzKDIwMTgsImFjczUiKQ0KZGZfY2VuY3VzPWdldF9hY3MoZ2VvZ3JhcGh5ID0gInRyYWN0IiwNCiAgICAgICAgICAgICAgICAgIHZhcmlhYmxlcz1jKCJwb3AiPSJCMDEwMDFfMDAxIiksDQogICAgICAgICAgICAgICAgICBzdGF0ZT0iREMiLGdlb21ldHJ5PVRSVUUseWVhcj0yMDE4KSANCg0KZGZfY2Vucz1kZl9jZW5jdXMgJT4lIHNlbGVjdCgtbW9lKSAlPiUgc3ByZWFkKHZhcmlhYmxlLGVzdGltYXRlKSANCmRmX2NlbnNfYWRqPWRmX2NlbnMgJT4lIHN0X3RyYW5zZm9ybSg0MzI2KQ0KYGBgDQoNCiMjIyBKb2luIENlbnN1cyBkYXRhIHRvIG1hcHBpbmcgZGF0YQ0KYGBge3J9DQpkZl9qPXN0X2pvaW4oZGZfY2Vuc19hZGosbmVpZ2gzLGxhcmdlc3Q9VFJVRSkNCmBgYA0KDQojIyMgU3VtbWFyaXplIHBvcHVsYXRpb24gZm9yIGVhY2ggbmVpZ2hib3VyaG9vZA0KYGBge3J9DQpkZjM9ZGZfaiAlPiUgc2VsZWN0KHBvcCxjb2RlKSAlPiUNCiAgZ3JvdXBfYnkoY29kZSkgJT4lDQogIHN1bW1hcmlzZShwb3Bfbj1zdW0ocG9wKSkNCiAgICAgICAgICAgIA0KICAgICAgICAgICAgDQpgYGANCg0KIyMjIEpvaW4gcG9wdWxhdGlvbiBkYXRhIGFuZCBnZW5lcmF0ZSByZXN1bHRzDQoNClJlbW92ZWQgYW55IGV4dHJlbWUgb3V0bGllcnMgYW5kIGdlbmVyYXRlZCBtYXAgdG8gY29tcGFyZSB0ZXN0aW5nIHJhdGVzIGFuZCBjb3ZpZCByYXRlcw0KDQpgYGB7cn0NCmRmND1sZWZ0X2pvaW4obmVpZ2gzLGRmMyAlPiUgc3Rfc2V0X2dlb21ldHJ5KE5VTEwpKQ0KDQpkZjQ9ZGY0ICU+JSBtdXRhdGUoIGNvdmlkX3JhdGU9dG90YWxfcG9zaXRpdmVzL3BvcF9uLCB0ZXN0X3JhdGU9dG90YWxfdGVzdHMvcG9wX24pDQpkZjQgJT4lIGZpbHRlcighKGNvZGUgJWluJSBjKCJOMCIsIk4xNSIsIk4yNCIpKSkgJT4lIHRtX3NoYXBlKCkrdG1fcG9seWdvbnMoYygiY292aWRfcmF0ZSIsInRlc3RfcmF0ZSIpKQ0KYGBgDQoNCg0K